COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 MACLSP - E swapper.
C00013 ENDMK
C⊗;
;;; MACLSP - E swapper.
;;; Written by Jorge Phillips, June 1977

(declare (*lexpr et))

(defun et elst
;;; et is a lexpr. it expects args as follows
;;; 	((fil ext (p pn)) page# line#)
;;; all are optional except the file and in this one only the fil is necessary
;;; ext and (p pn) can be omitted to.
(cond((= elst 0)(tetv))
     (t
      (and (> elst 3) (break '|ET losing args| t))
      (and (> (length (arg 1)) 3)
	   (break '|ET - losing filename| t))
      ((lambda (w)			;w is bound to list of args
	       (prog (fil p n)
		     (setq fil (***g (car w)))
		     (do ((v (cdr w) (setq v (cdr v)))	;cdr down w
			  (i 0 (1+ i)))
			 ((or (= i 2) (null v)))
			 (or (and (= i 0)(setq p (car v)))
			     (setq n (car v))))
		     (apply 'etv (append fil (list n p))))) ;p = page n = line
       (listify elst)))))

(defun ***g (x)
;;; x is a flie list of form (fil ext (pro prog)) or (fil) or (fil (pro prog))
;;; returns a list of 6bit numbers that represent the name
(prog (fil ext p pn)
      (setq fil (mak6 (car x)))
      (do ((y (cdr x) (cdr y)))
	  ((null y))
          (cond ( (and (eq (typep (car y)) 'list) (= (length (car y)) 2))
		  (setq p (mak6 (caar y)))
		  (setq pn (mak6 (cadar y))) )
		( (atom (car y)) (setq ext (mak6 (car y)))))) 
      (or (and (null p) (return (list fil ext nil)))
          (return (list fil ext (mergeppn p pn))))))

(defun mak6 (x)
;;; returns a 6bit if non-nil atom else breaks
(or (make6bit x) (break badfile t)))

(defun make6bit (x)
;;; x is an atom otherwise returns nil
(and x (atom x) (or (and (fixp x) (fix6bit x))(car (pnget x 6)))))

(defun fix6bit (x)
;;; x is a fixnum. converts into sixbit
((lambda (w)
   (and (> (length w) 3) (rplacd (cddr w) nil))
   (makfix6 (mapcar (function (lambda (y) (car (pnget y 6)))) w)))
 (explodec x)))

(LAP ETV SUBR)
(ARGS ETV (NIL . 5))
;;; args are as follows
;;; 	A  --> 	filnam in sixbit
;;; 	B  -->  extension in sixbit, modes in lower part
;;;	C  -->  ppn in form p,,pn
;;;   AR1  -->  line #
;;;  AR2A  -->  page #
;;; E is started at start+1 and args are moved to 11,13,14,15,16 before swap
;;; an entry point is provided that needs no args for running on tmpcor
	(PUSHJ P SAVACS)
  	(MOVEI 11 *)
  	(CALLI 11 2)			;pretend DDT is loaded
 	(MOVEM P (+ ACS 14))		;save new P
	(MOVE 11 0 C)			;get filename 6bit integer
	(MOVE 13 0 B)			;get ext-mode 6bit integer (since fixnum)
	(PUSHJ P LSH13)			;shift left ext till ok
	(HRRI 13)			;clear mode bits in ext
	(MOVE 14 0 A)			;filename 6bit from fixnum
	(JUMPE AR1 NOLINE)		;no line
	(MOVE 15 0 AR1)			;get line#
	(JRST 0 PAGE)			;is there a page#
NOLINE	(HLLZI 15)			;no line
PAGE    (JUMPE AR2A NOPAGE)		;no page
	(MOVE 16 0 AR2A)		;get machine number
	(JRST 0 DONE)			;everything taken care of
NOPAGE  (HLLZI 16)			;no page
DONE	(MOVEI TT 1)
	(JRST 0 SWAP)			;start at start+1
(ENTRY TETV SUBR)
(ARGS TETV (NIL . 0))
	(PUSHJ P SAVACS)
	(MOVEI 11 *)
	(CALLI 11 2)
 	(MOVEM P (+ ACS 14))		;save new P
	(HLLZI 11)
	(HLLZI 13)
	(HLLZI 14)
	(HLLZI 15)
	(HLLZI 16)
	(MOVEI TT 1)
SWAP	(MOVEM TT (+ EBUF 3))		;swap address (tmpcor=-1)
     	(TTCALL 11)			;clrbufi so E doesnt barf
	(MOVE TT (% 0 0 EBUF))
	(HRL TT (% 0 0 DMPBUF))		;[dmp,,e]
	(HLLZI 0)    			;get jobname
	(CALLI 0 400062)		;GETNAM
	(MOVEM 0 (+ DMPBUF 1))		;clobber nil
	(MOVE 1 (% SIXBIT TMP))		;file is <jobnam>.tmp
	(HLLZI 3)                   	;ppn
	(MOVE 6 (% SIXBIT DSK))		;dev is DSK always
FOO	(CALLI TT 400004)		;SWAP uuo
;	we will delete the tempfile here
STRT	(HRLZI 17 ACS)		 	;restore acs
	(BLT 17 17)
	(PUSH FXP 0)
	(PUSHJ P DELFIL)
	(POP FXP 0)
	(HLLZI A)			;we return here. return NIL
	(POPJ P)

;;; useful routines

DELFIL  (OPEN 5 OPNBUF)			;OPEN the dsk on channel 5 mode 0
	(POPJ P)			;can't init dsk! foo!!
 	(SETZM 0 (+ DSKBUF 3))		;zero PPN
	(MOVE 0 (+ DMPBUF 1))		;get file name
	(MOVEM 0 DSKBUF)
	(LOOKUP 5 DSKBUF)		;LOOKUP file
	(POPJ P)			;cant. bletch!
	(RENAME 5 RENBUF)		;delete the file
	(POPJ P)			;can't??
	(POPJ P)			;bye
RENBUF  (0)				;for deletion
	(0)
	(0)
	(0)
OPNBUF	(0)
	(SIXBIT DSK)
	(0)				;no buffers

SAVACS	(MOVEM 17 (+ ACS 17))	        ;save the accs
	(MOVEI 17 ACS)
	(BLT 17 (+ ACS 16))
	(POPJ P)

LSH13	(PUSH FXP C)			;save C
	(MOVSI C -2)			;at most two null chars
	(TLNN 13 770000)		;is first byte 0?
	(LSH 13 6)			;yea, shift it
	(AOBJN C (- * 2))		;keep on going
	(POP FXP C)			;restore C
	(POPJ P)			;return

ACS	(BLOCK 20)			;save area for swap

;;; buffer for lookup of dump file
DSKBUF  (0)				;filename for dumpfile
	(SIXBIT TMP)			; extension (not clobbered)
	(0)				;??
	(0)				;must zero this word every time

DMPBUF  (SIXBIT DSK)			;dump file buffer
	(0)             		;<jobnam> on luser's alias
	(SIXBIT |TMP  !|)		;turn on swap of high seg ie TMP,,1
	(FOO)				;kludge. see comment below
	(0)				;lusers ppn
;;; notice the hack! it seems E returns to JOBSA+1 when xrunning so have
;;; to give STRT-1 so it works. Lose, lose.
EBUF 	(SIXBIT DSK)
 	(SIXBIT E)			;get E.DMP[1,3]
	(0)
	(0)     			;start addr
	(SIXBIT |  1  3|)		;ppn
	(0)				;run on logged in ppn

(ENTRY MERGEPPN SUBR)
(ARGS MERGEPPN (NIL . 2))
;;; places p in left and pn in right half
	(MOVE TT 0 A)			;get prj sixbit into TT
	(JSP T NORMAL)			;right justify within halfword
	(PUSH FXP TT)			;save in stack
	(MOVE TT 0 B)			;get pn sixbit
	(JSP T NORMAL)			;same
	(HLRZ TT TT)			;TT has 0,,pn
	(HLL TT 0 FXP)			;TT now has p,,pn
	(MOVE A TT)			;return p,,pn
	(JSP T FXCONS)			;get fixnum
	(POP FXP FXP)
	(POPJ P)
NORMAL	(MOVSI D -3)			;at most 3 sixbit chars
        (TLNE TT 000077)		;last 6 bits are zero?
	(JRST 0 ALL)			;OK tested
	(LSH TT -6)			;shift right 6 bits
	(AOBJN D (- * 3))
ALL	(JRST 0 @ T)			;return

(ENTRY MAKFIX6 SUBR)
(ARGS MAKFIX6 (NIL . 1))
;;; receives a list of fixnums. transforms it into a sixbit left justified
;;; word. returns fixnum
	(MOVEI C 1)			;first time around
DO	(HLRZ TT 0 A)			;TT contains car A
	(JSP T ADDIT)			;B first dig. will assemble here
	(HRRZ A 0 A)			;CDR A
	(JUMPN A DO)			;not nil?
	(MOVE TT B)			;yes nil, so A←result
	(JSP T FXCONS)			;get fixnum
	(POPJ P)
ADDIT   (CAIE C 1)			;first time?
	(JRST 0 NO1ST)			;no
	(SETZ C)			;clear flag
	(MOVE B 0 TT)			;get machine integer
	(LSH B -14)			;B at 000077,,0
	(JRST 0 @ T)			;return
NO1ST   (MOVE AR1 0 TT)
	(LSH AR1 -14)			;AR1 has 0000dd,,0
	(LSH B 6)			;B at 00mm00,,0
	(IOR B AR1)			;OR them
	(JRST 0 @ T)			;return
NIL